home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / ti-low.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-07-09  |  3.0 KB  |  84 lines
  1. ;;; -*- Mode:LISP; Package:(PCL (Lisp WALKER)); Base:10.; Syntax:Common-lisp; Patch-File: Yes -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; This is the 3600 version of the file portable-low.
  28. ;;;
  29.  
  30. (in-package 'pcl)
  31.  
  32. (defmacro without-interrupts (&body body)
  33.   `(let ((outer-scheduling-state si:inhibit-scheduling-flag)
  34.      (si:inhibit-scheduling-flag t))
  35.      (macrolet ((interrupts-on  ()
  36.           '(when (null outer-scheduling-state)
  37.              (setq si:inhibit-scheduling-flag nil)))
  38.         (interrupts-off ()
  39.           '(setq si:inhibit-scheduling-flag t)))
  40.        ,.body)))
  41.  
  42. (si:defsubst std-instance-p (x)
  43.   (si:typep-structure-or-flavor x 'std-instance))
  44.  
  45.   ;;   
  46. ;;;;;; printing-random-thing-internal
  47.   ;;
  48. (defun printing-random-thing-internal (thing stream)
  49.   (format stream "~O" (si:%pointer thing)))
  50.  
  51. (eval-when (compile load eval)             ;There seems to be some bug with
  52.   (setq si::inhibit-displacing-flag t))       ;macrolet'd macros or something.
  53.                        ;This gets around it but its not
  54.                        ;really the right fix.
  55.  
  56. (defun function-arglist (f)
  57.   (sys::arglist f t))
  58.  
  59. (defun record-definition (type spec &rest ignore)
  60.   (if (eql type 'method)
  61.       (sys:record-source-file-name spec 'defun :no-query)
  62.       (sys:record-source-file-name spec type :no-query)))
  63.  
  64. (ticl:defprop method method-function-spec-handler sys:function-spec-handler)
  65. (defun method-function-spec-handler
  66.        (function function-spec &optional arg1 arg2)
  67.   (let ((symbol (second function-spec)))
  68.     (case function
  69.       (sys:validate-function-spec t)
  70.       (otherwise
  71.     (sys:function-spec-default-handler
  72.       function function-spec arg1 arg2)))))
  73.  
  74. ;;;Edited by Reed Hastings         13 Aug 87  16:59
  75. ;;;Edited by Reed Hastings         2 Nov 87  22:58
  76. (defun set-function-name (function new-name)
  77.   (when (si:get-debug-info-struct function)
  78.     (setf (si:get-debug-info-field (si:get-debug-info-struct function) :name)
  79.       new-name))
  80.   function)
  81.  
  82.  
  83.  
  84.